perm filename MAINPR.SAI[PNT,HE]3 blob
sn#337566 filedate 1978-02-25 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00029 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 initial declarations and global variables
C00008 00003 ! facilities: error messages,syntax explanations,error,abort1
C00013 00004 ! parsing procedures
C00014 00005 ! symbol table: definition, inizialization
C00019 00006 ! display, input/output procedures
C00023 00007 ! display, input/output procedures
C00027 00008 ! symbol table: check,checktot,ensym,delsym,newsym,oldsym
C00033 00009 ! call to KILL instruction (if #KILL=TRUE)
C00034 00010 ! symbol table: mk_rec , require operat.hdr
C00036 00011 ! symbol table: nwr,new_sc,new_vt,new_rt,new_tr,new_fr,require expr.hdr,dcdsym
C00038 00012 ! symbol table: control,insertion
C00044 00013 ! symbol table: killtree,killvar,reset
C00050 00014 ! assignment instruction
C00052 00015 ! tree operations: affixcode,unfixcode (afx_node)
C00056 00016 ! tree operations: copycode,copy,copy_tree
C00061 00017 ! arm interactions: read_pos,readarm,asgloc,frasg,inputcode
C00068 00018 ! arm interactions: arm_check,goarm,movefrfr
C00072 00019 ! arm interactions: mvfrcode,mvfrexp
C00074 00020 ! arm interactions: centercode,closecode,opencode,implconstr
C00080 00021 ! system facilities: editcode,renmcode
C00084 00022 ! parse procedures: affixproc,bailcall
C00086 00023 ! parse procedures: centerproc,opclproc,constread,copyproc
C00093 00024 ! parse procedures: declproc,deleteproc,driveproc,editproc,exitproc,explass,freeproc
C00099 00025 ! parse procedures: inputproc,killproc,vtrtpart,moveproc,axmovproc
C00103 00026 ! parse procedures: other
C00107 00027 ! parse procedures: parking,readproc,renmproc,writeproc,unfixproc
C00110 00028 ! parse
C00118 00029 ! main program
C00121 ENDMK
C⊗;
comment initial declarations and global variables;
EXTERNAL INTEGER !SKIP!;
REQUIRE 300 STRING_PDL;REQUIRE 1000 SYSTEM_PDL;
REQUIRE "MACROS.SAI[PNT,HE]" SOURCE_FILE;
INTERNAL STRING $LINE,$NEXT,$TAIL,TOKEN;
! $line is the line typed on tty;
! $next is the part of $line to be parsed;
! $tail is the part of instr. to be scanned until;
! TOKEN is the last token read;
INTERNAL INTEGER #TOKEN; ! type of last token read by gtoken;
INTERNAL BOOLEAN STOKEN; ! true if the next token to be
read is yet in TOKEN;
LABEL MAINL; ! used by abort procedures to go to the top level;
INTERNAL REAL $EPS;
INTERNAL STRING $TTYFL; ! name of file for tty input;
INTERNAL BOOLEAN $READ; ! true while reading from a file;
INTEGER $INPCH; ! channel # for current reading;
INTERNAL INTEGER $TOTFL; ! number of files defined;
INTERNAL STRING $ALFL; ! last file used for output;
INTERNAL BOOLEAN $OUT; ! if true output is required;
INTERNAL INTEGER $TTYCH; ! this is used in parser.sai too;
INTERNAL INTEGER $ARROW; ! arrow vertical position;
INTERNAL STRING $TRLST,$FRLST,$SCLST,$VTLST,$RTLST,$OULST,$DFLST;
INTERNAL INTEGER $ALLOW; ! when >0 no display updating;
INTERNAL INTEGER $EOF,$BRCHR;
INTERNAL INTEGER $RETAB,$SKTAB,$SPCTAB,$SCNTAB,$NUMTAB,$ALFTAB,$DSHTAB,$ERRTAB,
$CMNTAB,$BSKTAB,$DPYTAB,$FFTAB,$HLPTAB;
INTERNAL STRING $BLANK;
PROCEDURE INIBRK;
BEGIN
STRING BTABLE;
BTABLE←".,;[]()+-*/←↑↓→?α$|⊗"&LF&CR&TAB&FF&SP;
SETBREAK ($SCNTAB←GETBREAK,";?{",CR&LF&FF&TV,"INAK"); ! general table;
SETBREAK ($RETAB ←GETBREAK,BTABLE,NULL,"INR"); ! used by gtoken;
SETBREAK ($SKTAB ←GETBREAK,BTABLE,NULL,"INS");
SETBREAK ($SPCTAB←GETBREAK,TAB&SP,NULL, "XNR");
SETBREAK ($ALFTAB←GETBREAK,NULL,NULL,"XRN");
SETBREAK ($NUMTAB←GETBREAK,"@+-0123456789",NULL,"XNR"); ! as table 10;
SETBREAK ($CMNTAB←GETBREAK,"}",NULL,"INA"); ! used for comments;
SETBREAK ($DSHTAB←GETBREAK,"_",NULL,"INS"); ! used by COPY/MERGE;
SETBREAK ($ERRTAB←GETBREAK,BTABLE,SP&CR,"IN"); ! used while recovering;
SETBREAK ($BSKTAB←GETBREAK,NULL,SP,"IN"); ! used to eliminate blanks;
SETBREAK ($DPYTAB←GETBREAK,CR,CRLF,"INS"); ! used for display;
IFC #HELP THENC
SETBREAK ($HLPTAB←GETBREAK,"\",NULL,"INS");
SETBREAK ($FFTAB←GETBREAK,FF,NULL,"INS"); ENDC
$BLANK←" ";
SETFORMAT(0,3);
END;
REQUIRE INIBRK INITIALIZATION ;
! facilities: error messages,syntax explanations,error,abort1;
IFC #HELP THENC REQUIRE "HELP.HDR[PNT,HE]" SOURCE_FILE;ENDC
INTEGER $HELP; ! used by error;
IFC #KILL THENC INTERNAL INTEGER $LAST;ENDC ! used by kill;
! error messages for syntactic errors;
PRESET_WITH
"--→ ; ",
"--→ , ",
"--→ . ",
"--→ [ ",
"--→ ] ",
"--→ ( ",
"--→ ) ",
"--→ + ",
"--→ * ",
"--→ ALONG ",
"--→ BY ",
"--→ INTO ",
"--→ REL ",
"--→ ROT ",
"--→ TO ",
"--→ TRANS ",
"--→ WRT ",
"--→ XHAT or YHAT or ZHAT ",
"--→ YARM or BARM ",
"--→ YHAND or BHAND ",
"--→ INPUT after ↑, ↓, ∨, ∧, <, >",
"--→ identifier ",
"--→ number ",
"--→ file name ",
"--→ arithmetic operator ",
"required ←--",
"--→ error in explicit ",
"vector ←--",
"rotation ←--",
"frame ←--",
"--→ affix_type is wrong ←--",
"--→ wrong identifier or wrong number ←--",
"--→ unrecognized instruction ←--",
"| ",
"VECTOR required after DISTANCE";
INTERNAL STRING ARRAY $SYNMSG[0:34];
! error messages used for semantic errors;
! the first messages cannot be moved in another position because they
are referred to using the type of the variables(#SC,#VT,#RT,@TR,@FR);
PRESET_WITH
" scalar not existent ",
" vector not existent ",
" rotation not existent ",
" trans not existent ",
" frame not existent ",
" is not scalar nor vector nor rotation ",
" object not existent ",
" out of symbol table",
" cannot be moved ",
" already defined symbol ",
" dismatching of types ",
" affixed frame ",
" reading on arm required ",
" not executed instruction";
INTERNAL STRING ARRAY $SEMSG[0:13];
! warning : the value 0 assigned to $LAST in this page corresponds
to the macro KIL (here not yet defined);
INTERNAL PROCEDURE ESC_P;
BEGIN
define ttyset = "'047000400121";
quick_code
hrroi 1,['004000000120]; comment [004000,,"P"];
ttyset 1, ; ! this last stuff does an esc-P;
end;
END;
! called after syntax error. If required gives explanation of the error;
INTERNAL PROCEDURE ERROR(STRING ERR1,ERR2(NULL));
BEGIN
STRING ANSWER;
PRINT (ERR1,ERR2,CRLF);
PRINT(" ",TOKEN," ",$TAIL,IFC #HELP THENC "(? for more explanation)"
ELSEC CRLF ENDC);
IFC #HELP THENC
ANSWER←INCHRW;IF ANSWER=CR THEN INCHRW;
OUTSTR(CRLF);
IF ANSWER="?" THEN HLPMSG($HELP); ! if required gives explanations;
ENDC
IFC #DISPL THENC
IF NOT $READ THEN $ALLOW←0; ! while reading display is not updated;
ENDC
IFC #KILL THENC $LAST←0;ENDC ! impossible to kill the instruction;
PRINT("* ");ESC_P;
LODED($NEXT&CR); ! so it is possible to correct the command;
GO TO MAINL; ! goes to the main loop;
END;
! called after unrecoverable semantic error;
INTERNAL PROCEDURE ABORT1(STRING NAME,ERROR(NULL));
BEGIN
PRINT (NAME,ERROR,CRLF);
IFC #DISPL THENC
IF NOT $READ THEN $ALLOW←0; ! while reading display is not updated;
ENDC
IFC #KILL THENC $LAST←0;ENDC ! impossible to kill the instruction;
PRINT("* ");ESC_P;
LODED($NEXT&CR); ! so it is possible to correct the command;
GO TO MAINL; ! goes to the main loop;
END;
! parsing procedures;
REQUIRE "PARSER.HDR[PNT,HE]" SOURCE_FILE;
INTERNAL STRING OLDOBJ; ! used for defaults;
STRING OLDCMD; ! used for defaults;
! saves important parts of last instruction, for default instructions.
Oldobj is used to pass to gettoken the value corresponding to the ⊗;
SIMPLE PROCEDURE OLDSAV(STRING CMD,OBJ);
BEGIN
OLDCMD←CMD;
OLDOBJ←OBJ;
END;
! symbol table: definition, inizialization;
DEFINE #MIN = 1; ! minimum integer value used for types;
DEFINE #MAX = 5; ! maximun integer value used for types;
DEFINE #NTYPE = #MAX-#MIN +1; ! 5 data types= 5 classes of records;
DEFINE #LTYPE = 100; ! number of elements for each type;
DEFINE #LMT= #NTYPE*#LTYPE; ! # of postions in symtab;
INTERNAL RCLASS SYMBOL (STRING PNAME;RANY OBJECT);
! pname=pname of the symbol;
! object=pointer to the record of the appropriate class;
INTERNAL RPTR (SYMBOL) ARRAY $YMTAB[0:#LMT]; ! symbol table;
INTERNAL INTEGER ARRAY $ENTRY[#MIN:#MAX];
! each position (corresponding to one type) contains the index
of the first position free in $YMTAB for that class;
INTERNAL RCLASS SCALAR (REAL VALUE);
! value=value of the scalar;
INTERNAL RCLASS VECTOR (REAL XC,YC,ZC);
! xc,yc,zc=value of the component of the vector along x,y,z axis;
INTERNAL RCLASS FRAME (STRING PNAME; RPTR (FRAME) DAD,SON,EBRO,YBRO; INTEGER HOWLINKED;
REAL ARRAY XF);
! pname=pname of the frame;
! dad,son,ebro,ybro=pointers to dad,son,elder and younger brother
in frame tree;
! howlinked=kind of affixment(rigid,nonrigid,independent);
! xf=array of values
xf[1:3,1:3]=rotation matrix,
xf[1:3,4]=translation vector,
xf[4,1:3]=0,
xf[4,4]=1,
xf[5,1:3]=rotation angles,
xf[5,4]>0 if angles are valid;
INTERNAL RCLASS ROT (REAL ARRAY XF);
! xf=array of values (as for frame class);
INTERNAL RCLASS TRANS(REAL ARRAY XF);
! xf=array of values (as for frame class);
! records not entered in $YMTAB, used for computations;
INTERNAL INTEGER $ROW;
! row in $YMTAB of last checked symbol (used by kill operation);
! pointers to predeclared symbols;
INTERNAL RPTR(SYMBOL)HANDB,HANDY,INCHES,DEG;
INTERNAL RPTR(SCALAR) S_BHAND,S_YHAND;
! for scalars BHAND,YHAND;
REAL BHAND; ! used by ARMINT to transfer the coordinates of BHAND;
INTERNAL RPTR(SYMBOL)XHAT,YHAT,ZHAT,NILVECT;
INTERNAL RPTR(VECTOR) V_XHAT,V_YHAT,V_ZHAT,V_NILVECT;
! for vectors XHAT,YHAT,ZHAT,NILVECT;
INTERNAL RPTR(SYMBOL)WORLD,BARM,YARM,BPARK,YPARK,BGRASP,POINTER;
INTERNAL RPTR(FRAME) F_BARM,F_YARM,F_BPARK,F_YPARK,F_BGRASP,F_POINTER,F_FID;
INTERNAL RPTR(FRAME) F_WRLD;
! for frames STATION,BARM,YARM,BPARK,YPARK,POINTER;
INTERNAL RPTR(SYMBOL)NILROTN;
INTERNAL RPTR(ROT) R_NILROTN;
! for rotation NILROTN;
INTERNAL RPTR(SYMBOL)NILTRANS;
INTERNAL RPTR(TRANS) T_NILTRANS;
! for trans NILTRANS;
INTERNAL RPTR(FRAME) F_ARM;
! F_ARM points to the arm holding pointer,
F_FID points to the record FIDUCIAL (when defined);
RPTR(TRANS) ARRAY T_CSTR[1:3];
! used by CONSTRUCT instruction;
PROCEDURE INISYM; ! initialization of $ENTRY;
BEGIN
INTEGER I;
FOR I←#MIN STEP 1 UNTIL #MAX DO
$ENTRY[I]←(I-#MIN)*#LTYPE;
END;
REQUIRE INISYM INITIALIZATION;
IFC #ARROW THENC
REQUIRE "ARROW[PNT,HE]" LOAD_MODULE;
ELSEC
INTERNAL SIMPLE PROCEDURE ARROW; ;
ENDC
! display, input/output procedures;
REQUIRE "OUTPUT.HDR[PNT,HE]" SOURCE_FILE;
! calls the file OUTPUT.SAI with some procedures used by disply and
input/output. Depending on the values of #DISPL and #OUTPT calls
also DISPLY.SAI and/or INPOUT.SAI;
! called when an indefined variable is used. Tries to recover, asking
the correct name of the variable, and returns it.
(null string or <control-C> to return to the main loop);
STRING PROCEDURE RECOVER(STRING SYMB);
BEGIN "R"
STRING ANSWER;LABEL CC;
! you can change the identifier symb;
CC:
LODED(SYMB&CR);
ANSWER←INCHWL; ! reads new identifier;
IFC #OUTPT THENC
IF $OUT THEN CPRINT($TTYCH,ANSWER,CRLF);
ENDC
SYMB←SCAN(ANSWER,$ERRTAB,$BRCHR); ! eliminates blanks and checks break;
IF $BRCHR≠0 AND $BRCHR≠'40
THEN BEGIN
PRINT("break character found. Try again ");
GO TO CC; ! so... you can try again;
END
ELSE IF SYMB THEN RETURN(SYMB); ! a "good" symbol is returned;
! you want to delete the instruction being interpreted;
CLRBUF;
IFC #DISPL THENC
IF NOT $READ THEN $ALLOW←0; ! while reading display is not updated;
ENDC
IFC #KILL THENC $LAST←0;ENDC ! impossible to kill the instruction;
PRINT($SEMSG[13],CRLF,"* ");
ESC_P;
GO TO MAINL; ! goes to the main loop;
END "R";
IFC #OUTPT THENC
! allows recovering if a file not available has been required
(null string or <control-C> to return to the main loop);
INTERNAL STRING PROCEDURE FRCVER(STRING FILE);
BEGIN "F"
STRING ANSWER;
LODED(FILE&CR); ANSWER←INCHWL;
IFC #OUTPT THENC
IF $OUT THEN CPRINT($TTYCH,ANSWER,CRLF);
ENDC
$TAIL←SCAN(ANSWER,$BSKTAB,$BRCHR); ! scan to eliminate $BLANK;
! reads from tail and return a file name otherwise deletes the instr.;
IF $TAIL
THEN RETURN(NAMEFILE)
ELSE BEGIN
CLRBUF;
IFC #DISPL THENC
IF NOT $READ THEN $ALLOW←0; ! while reading display is not updated;
ENDC
IFC #KILL THENC $LAST←0;ENDC ! impossible to kill the instruction;
PRINT($SEMSG[13],CRLF,"* ");
ESC_P;
GO TO MAINL; ! goes to the main loop;
END;
END "F";
ENDC
! display, input/output procedures;
IFC #DISPL THENC
SIMPLE STRING PROCEDURE DEFAULT;
RETURN(" "&OLDCMD&CRLF&" "&OLDOBJ&CRLF);
! update the display (if $ALLOW=0);
INTERNAL PROCEDURE UPDATE;
BEGIN
IF $ALLOW>0 THEN RETURN;
DPYDRAW;
IF NOT $SCLST THEN $SCLST←DPY_STRING(#SC);
IF NOT $VTLST THEN $VTLST←DPY_STRING(#VT);
IF NOT $RTLST THEN $RTLST←DPY_STRING(#RT);
IF NOT $TRLST THEN $TRLST←DPY_STRING(#TR);
IF NOT $FRLST THEN $FRLST←TREE_STRING;
IFC #OUTPT THENC IF NOT $OULST THEN $OULST←FILE_STRING;ENDC
OUTDPY;
DPYOUT(1);ESC_P;
END;
ENDC
IFC #OUTPT THENC
! these procedures used to read from a file are here and not in
the input/output module becuase the READEXEC procedure calls
the PARSE procedure for each instruction;
FORWARD RECURSIVE PROCEDURE PARSE;
PROCEDURE READEXEC;
BEGIN "A"
INTEGER CHAR;
IFC #DISPL THENC DPYFREE;ENDC
$TAIL←INPUT($INPCH,$SCNTAB);
WHILE NOT $EOF DO
BEGIN
IF NOT EQU($TAIL[1 TO 7],"COMMENT")
THEN BEGIN ! comments and the directory page;
PRINT($TAIL,CRLF); ! are so skipped;
PARSE; STOKEN←FALSE;
END;
CHAR←INCHRS;
! if you want to stop the execution of this instruction
you have to type something on tty;
IF CHAR≥0 THEN DONE;
$TAIL←INPUT($INPCH,$SCNTAB);
END;
RELEASE($INPCH);
$READ←FALSE;
IFC #DISPL THENC $ALLOW←0; ENDC
PRINT(CRLF,"type <CR> to come back to the display");
CHAR←INCHRW;CLRBUF;
IFC #DISPL THENC UPDATE;ENDC
IFC #KILL THENC $LAST←0;ENDC
END "A";
PROCEDURE READCODE(STRING FID);
BEGIN
OPEN($INPCH←GETCHAN,"DSK",0,3,0,1000,$BRCHR,$EOF);
LOOKUP($INPCH,FID,$EOF);
WHILE $EOF
DO BEGIN
PRINT("enter failed");
FID←FRCVER(FID);
LOOKUP($INPCH,FID,$EOF);
END;
$READ←TRUE;
IFC #DISPL THENC $ALLOW←$ALLOW+1;ENDC
READEXEC;
END;
CLEANUP FCLOSE;
ENDC
! called after reading ?. Gives some information, erasing the display;
IFC #HELP THENC
SIMPLE PROCEDURE HELPREQUEST;
BEGIN "H"
IFC #DISPL THENC DPYFREE;ENDC
! reads the comand after ?, if there is;
$TAIL←SCAN($LINE,$SCNTAB,$BRCHR);
HLPDO($TAIL); ! in HELP.SAI[1,MLG];
IFC #DISPL THENC UPDATE;ENDC
END "H";
ENDC
! symbol table: check,checktot,ensym,delsym,newsym,oldsym;
! checks if symbol symb, of type nm, is in symbol table in the class nm,
and return its pointer;
INTERNAL RPTR(SYMBOL) PROCEDURE CHECK(STRING SYMB;INTEGER NM);
BEGIN
RPTR(SYMBOL) TEMP;INTEGER IND,I;
IND←$ENTRY[NM]-1; ! address of last record of type nm filled;
FOR I← (NM-#MIN)*#LTYPE STEP 1 UNTIL IND DO
BEGIN
TEMP←$YMTAB[I];
IF TEMP≠NULL_RECORD
THEN IF EQU(SYMBOL:PNAME[TEMP],SYMB)
THEN BEGIN
IFC #KILL THENC $ROW←I;ENDC
RETURN(TEMP);
END;
END;
RETURN(NULL_RECORD); ! symbol not found;
END;
! checks if symbol symb is in symbol table, determines its class and
return its pointer;
RPTR(SYMBOL) PROCEDURE CHECKTOT(STRING SYMB;REFERENCE INTEGER NM);
BEGIN
INTEGER IND,I,K;RPTR(SYMBOL)TEMP;
FOR K←#MIN STEP 1 UNTIL #MAX DO
BEGIN
TEMP←CHECK(SYMB,K);
IF TEMP≠NULL_RECORD
THEN BEGIN
NM←K; ! changes the value of REFERENCE variable;
RETURN(TEMP);
END;
END;
RETURN(NULL_RECORD); ! symbol not found;
END;
! enters the symbol symb and the pointer to its node in symbol table,
in the class nm. The record of the class SCALAR,VECTOR,ROT,TRANS or
FRAME has to be constructedbefore calling ENSYM;
INTERNAL RPTR(SYMBOL) PROCEDURE ENSYM(STRING SYMB;INTEGER NM;RANY VAL);
BEGIN
RPTR (SYMBOL) TEMP;INTEGER IND;
IND←$ENTRY[NM]; ! address of last record of type nm filled;
IF IND≥(NM+1-#MIN)*#LTYPE
THEN ABORT1($SEMSG[7]); ! out of symbol table;
TEMP←NEW_RECORD(SYMBOL);
$YMTAB[IND]←TEMP; ! pointer to the new record in $YMTAB;
$ENTRY[NM]←IND+1; ! updating of $ENTRY;
SYMBOL:PNAME[TEMP]←SYMB; ! pname of symbol;
SYMBOL:OBJECT[TEMP]←VAL; ! pointer to the record previously created;
RETURN(TEMP);
END;
! deletes the symbol, whose pointer is el and whose class is obtype;
PROCEDURE DELSYM(RPTR(SYMBOL)EL;INTEGER OBTYPE);
BEGIN
INTEGER ADDRIN,ADDRFN,I;
ADDRIN←#LTYPE*(OBTYPE-#MIN); ! initial addr. in $YMTAB for class;
ADDRFN← $ENTRY[OBTYPE]-1; ! final addr. in $YMTAB for class;
FOR I←ADDRIN STEP 1 UNTIL ADDRFN DO
IF $YMTAB[I]=EL
THEN BEGIN
$YMTAB[I]←NULL_RECORD;
DONE;
END;
END;
! returns a new symbol, if symb is present in $YMTAB. Id used before
inserting a new symbol in $YMTAB to be sure that a symbol with the
name has not been defined before. This procedure allows recovering;
STRING PROCEDURE NEWSYM(STRING SYMB);
BEGIN
RPTR(SYMBOL)TEMP;INTEGER OBTYPE;
! if there is a symbol with the same pname allows recovering;
TEMP←CHECKTOT(SYMB,OBTYPE);
WHILE TEMP≠NULL_RECORD
DO BEGIN
PRINT(SYMB,$SEMSG[9]);
SYMB←RECOVER(SYMB);
TEMP←CHECKTOT(SYMB,OBTYPE);
END;
RETURN(SYMB);
END;
! checks if symb is present in $YMTAB and returns its pointer and its
type (using the reference variable obtype), otherwise allows recovering.
Is used when the symbol required has to be present in $YMTAB (ex.
in EDIT or RENAME instruction);
RPTR(SYMBOL) PROCEDURE OLDSYM(REFERENCE STRING SYMB;REFERENCE INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)EL;
EL←CHECKTOT(SYMB,OBTYPE);
! if symbol is not in $YMTAB, recovering is allowed;
WHILE EL=NULL_RECORD
DO BEGIN
PRINT ($SEMSG[6]);
SYMB←RECOVER(SYMB);
EL←CHECKTOT(SYMB,OBTYPE);
END;
RETURN(EL);
END;
! call to KILL instruction (if #KILL=TRUE);
IFC #KILL THENC REQUIRE "KILLER.HDR[PNT,HE]" SOURCE_FILE;ENDC
IFC NOT #KILL THENC INTERNAL PROCEDURE SAVFR(RPTR(FRAME)N);BEGIN END; ENDC
! savfr is called in operat.sai. If the file KILLER.SAI is not loaded
this is a dummy declaration;
! symbol table: mk_rec , require operat.hdr;
INTERNAL RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME) PROCEDURE MK_REC(INTEGER TYPE);
BEGIN
RANY TEMP;
REAL ARRAY A[1:5,1:4];
A[1,1]←A[2,2]←A[3,3]←A[4,4]←A[5,4]←1.0;
CASE TYPE OF
begin "case"
[#SC] TEMP←NEW_RECORD(SCALAR);
[#VT] TEMP←NEW_RECORD(VECTOR);
[#RT] BEGIN
TEMP←NEW_RECORD(ROT);
MEMORY[LOCATION(ROT:XF[TEMP])]←MEMORY[LOCATION(A)];
END;
[#TR] BEGIN
TEMP←NEW_RECORD(TRANS);
MEMORY[LOCATION(TRANS:XF[TEMP])]←MEMORY[LOCATION(A)];
END;
[#FR] BEGIN
TEMP←NEW_RECORD(FRAME);
MEMORY[LOCATION(FRAME:XF[TEMP])]←MEMORY[LOCATION(A)];
! insert here the affixment to the world;
FRAME:HOWLINKED[TEMP]←#INDLK; ! independently;
END
end "case";
MEMORY[LOCATION(A)]←0;
RETURN(TEMP);
END;
REQUIRE "OPERAT.HDR[PNT,HE]" SOURCE_FILE;
! symbol table: nwr,new_sc,new_vt,new_rt,new_tr,new_fr,require expr.hdr,dcdsym;
RPTR(SYMBOL)PROCEDURE NWR(STRING SYMB; INTEGER TYP;REFERENCE STRING __LST);
BEGIN
RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)VAL; RPTR(SYMBOL)TEMP;
SYMB←NEWSYM(SYMB);
VAL←MK_REC(TYP);
TEMP←ENSYM(SYMB,TYP,VAL);
IF TYP=#FR THEN BEGIN FRAME:PNAME[VAL]←SYMB;
IF TEMP≠ WORLD THEN LINKFR(VAL,F_WRLD);
FRAME:PNAME[VAL]←SYMB;
FRAME:HOWLINKED[VAL]←#INDLK;
END;
IFC #KILL THENC SAVNEW(TEMP,TYP);ENDC
__LST←NULL;
IFC #DISPL THENC UPDATE;ENDC
RETURN(TEMP);
END;
DEFINE NEW_SC(DDDDD) "[][]" = [NWR(DDDDD,#SC,$SCLST)];
DEFINE NEW_VT(DDDDD) "[][]" = [NWR(DDDDD,#VT,$VTLST)];
DEFINE NEW_RT(DDDDD) "[][]" = [NWR(DDDDD,#RT,$RTLST)];
DEFINE NEW_TR(DDDDD) "[][]" = [NWR(DDDDD,#TR,$TRLST)];
DEFINE NEW_FR(DDDDD) "[][]" = [NWR(DDDDD,#FR,$FRLST)];
REQUIRE "EXPR.HDR[PNT,he]" SOURCE_FILE;
! checks if the symbol (scalar,vector or rotation) is in $YMTAB;
INTERNAL RPTR(TREE) PROCEDURE DCDSYM(STRING SYMB);
BEGIN
RPTR(SYMBOL)EL;INTEGER OBTYPE;
EL←CHECKTOT(SYMB,OBTYPE);
IF EL≠NULL_RECORD
THEN RETURN(NWTREE(SYMBOL:OBJECT[EL],OBTYPE))
ELSE RETURN(NWTREE(NULL_RECORD,0));
END;
! symbol table: control,insertion;
RPTR(SYMBOL)PROCEDURE CNVRTR(RPTR(SYMBOL)EL;STRING SYMB);
BEGIN
RPTR(TRANS) TEMP;
TEMP←SYMBOL:OBJECT[EL];
IFC #KILL THENC SAVOLD(EL,#TR);ENDC
DELSYM(EL,#TR);
EL←NEW_FR(SYMB);
ARRTRAN(FRAME:XF[SYMBOL:OBJECT[EL]],TRANS:XF[TEMP]);
$FRLST←$TRLST←NULL;
END;
! if the symbol symb is present in $YMTAB in the class OBTYPE returns
the pointer to it, otherwise allows recovering. The symbol is passed
by reference so after recovering the new symbol is sent back;
INTERNAL RANY PROCEDURE BELONGS (REFERENCE STRING SYMB;INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL) EL;
EL←CHECK(SYMB,OBTYPE); ! checks if symbol is present;
WHILE EL=NULL_RECORD
DO BEGIN
IF OBTYPE=#FR
THEN BEGIN
EL←CHECK(SYMB,#TR);
IF EL
THEN BEGIN
EL←CNVRTR(EL,SYMB);
RETURN(SYMBOL:OBJECT[EL]);
END;
END;
PRINT($SEMSG[OBTYPE-#MIN]);
SYMB←RECOVER(SYMB); ! recover can interrupt the loop and abort;
EL←CHECK(SYMB,OBTYPE);
END;
RETURN(SYMBOL:OBJECT[EL]); ! returns the pointer to the symbol;
END;
! checks if the symbol (scalar,vector or rotation) is in $YMTAB.
If not inserts it, and returns its pointer;
RPTR(SYMBOL) PROCEDURE INSERT(STRING SYMB;INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)EL;
EL←CHECK(SYMB,OBTYPE);
IF EL=NULL_RECORD
THEN CASE OBTYPE OF
BEGIN "CASE"
[#SC] EL←NEW_SC(SYMB);
[#VT] EL←NEW_VT(SYMB);
[#RT] EL←NEW_RT(SYMB);
[#TR] EL←NEW_TR(SYMB)
END "CASE"
ELSE IFC #KILL THENC SAVOLD(EL,OBTYPE);ENDC ! old values are saved;
RETURN(EL);
END;
! returns the pointer to the frame. If the frame is not present inserts it,
otherwise checks its affixment type and asks for a confirmation if
the affixment type is not independent. In that case recovering is allowed;
INTERNAL RPTR(FRAME) PROCEDURE FR_INSERT (REFERENCE STRING SYMB);
BEGIN "A"
RPTR(SYMBOL) EL;
RPTR(FRAME) FRA; STRING TEMP;INTEGER LINK;
WHILE TRUE
DO BEGIN "LOOP"
EL←CHECK(SYMB,#FR); ! if while copying;
IF $HELP=14
THEN WHILE EL≠NULL_RECORD
DO BEGIN
! while copying a new frame is required.
Recovering is allowed if the frame is existent;
PRINT($SEMSG[9]);
SYMB←RECOVER(SYMB);
EL←CHECK(SYMB,#FR);
END;
IF EL=NULL_RECORD
THEN BEGIN
EL←CHECK(SYMB,#TR);
IF EL THEN EL←CNVRTR(EL,SYMB)
ELSE EL←NEW_FR(SYMB); ! defines a new frame;
RETURN(SYMBOL:OBJECT[EL]);
END
ELSE BEGIN "C"
FRA←SYMBOL:OBJECT[EL];
LINK←FRAME:HOWLINKED[FRA];
! changing values of the frame is allowed if link is #INDLK;
IF LINK=#INDLK
THEN BEGIN
IFC #KILL THENC SAVOLD(EL,#FR);ENDC ! saves old values;
$FRLST←NULL;
RETURN(FRA);
END
ELSE BEGIN
! otherwise a confirmation is required;
PRINT(SYMB,
" affixed frame. Changing values can modify the frame tree.",CRLF,
"You can change the name ");
TEMP←RECOVER(SYMB);
! if the name of the frame is the same,
changing values is allowed;
IF EQU(TEMP ,SYMB)
THEN BEGIN
IFC #KILL THENC SAVOLD(EL,#FR);ENDC
$FRLST←NULL;
RETURN(FRA);
END
ELSE SYMB←TEMP;
END;
END "C";
END "LOOP";
END "A";
! this procedure is used to initialize the values of the predefined
frames. W,PH,TH are Euler angles, X,Y,Z are the coordinates;
INTERNAL RPTR(TRANS) PROCEDURE DOTREXP(REAL W,PH,TH,X,Y,Z);
BEGIN
RPTR(TRANS) XFE;
XFE←MK_REC(#TR);
SETROT(TRANS:XF[XFE],W,PH,TH);
TRANS:XF[XFE][1,4]←X;
TRANS:XF[XFE][2,4]←Y;
TRANS:XF[XFE][3,4]←Z;
RETURN(XFE);
END;
! symbol table: killtree,killvar,reset;
! removes from $YMTAB all nodes in the subtrees rooted at el;
RECURSIVE PROCEDURE KILLTREE (RPTR(SYMBOL) EL);
BEGIN
RPTR(FRAME)TEMP;
TEMP←SYMBOL:OBJECT[EL];
DELSYM(EL,#FR); ! removes el from $YMTAB;
TEMP←FRAME:SON[TEMP];
WHILE TEMP≠NULL_RECORD DO
BEGIN
EL←CHECK(FRAME:PNAME[TEMP],#FR);
IFC #KILL THENC SAVOLD(EL,#FR);ENDC ! saves the values;
KILLTREE(EL);
TEMP←FRAME:EBRO[TEMP];
END;
END;
! removes the symbol from $YMTAB;
PROCEDURE KILLVAR(REFERENCE STRING VAR);
BEGIN
RPTR (SYMBOL) EL;RPTR(FRAME)D;INTEGER OBTYPE;
IFC #KILL THENC $LAST←DEL;ENDC ! for kill instruction;
EL←OLDSYM(VAR,OBTYPE);
IF EL=WORLD OR EL=BARM OR EL=YARM OR EL=BPARK OR EL=YPARK
OR EL=NILVECT OR EL=XHAT OR EL=YHAT OR EL=ZHAT
OR EL=NILROTN OR EL=NILTRANS OR EL=HANDB OR EL=HANDY
THEN PRINT("I cannot delete ",VAR,CRLF)
ELSE BEGIN "DEL"
IF EQU(VAR,"FIDUCIAL") THEN F_FID←NULL_RECORD
ELSE IF EQU(VAR,"POINTER") THEN F_POINTER←F_ARM←NULL_RECORD
ELSE IF EQU(VAR,"BGRASP") THEN F_BGRASP←NULL_RECORD;
IF OBTYPE≠#FR
THEN BEGIN
IFC #KILL THENC SAVOLD(EL,OBTYPE);ENDC ! saves values;
DELSYM(EL,OBTYPE);
$SCLST←$VTLST←$RTLST←NULL;
END
ELSE BEGIN
RPTR(FRAME) TEMP;
TEMP←SYMBOL:OBJECT[EL];
IFC #KILL THENC SAVTRE(CHECK(FRAME:PNAME[TEMP],#FR));ENDC
! saves the tree;
UNLINK(TEMP); ! unfixes the frame;
KILLTREE(EL); ! deletes subtrees rooted in var;
$frlst←null;
END;
END "DEL";
END;
FORWARD INTERNAL PROCEDURE AFX_NODE(RPTR(FRAME)N,D;INTEGER HOW);
FORWARD PROCEDURE UFX_NODE(RPTR(FRAME)N,D);
FORWARD PROCEDURE READARM(RPTR(FRAME) POS);
! the procedure deletes all the variables defined by the user. It's
called by DELETE with no arguments. If other predefined variables
are inserted the values in the array SAVE have to be accordingly
modified;
PROCEDURE RESET;
BEGIN
INTEGER IND,I,TEMP;INTEGER ARRAY SAVE[#MIN:#MAX];RPTR(FRAME)WHAT;
IFC #KILL THENC $LAST←0;ENDC ! unkillable instruction;
SAVE[#SC]←2; ! 2 scalars predefined in the system;
SAVE[#VT]←4; ! 4 vectors;
SAVE[#RT]←1; ! 1 rotation;
SAVE[#FR]←5; ! 5 frames;
SAVE[#TR]←1; ! 1 trans;
FOR IND←#MIN STEP 1 UNTIL #MAX DO
BEGIN
! deletes the records defined for each type saving the predefined ones;
TEMP←$ENTRY[IND]-1;
FOR I←#LTYPE*(IND-#MIN)+SAVE[IND] STEP 1 UNTIL TEMP DO
$YMTAB[I]←NULL_RECORD;
$ENTRY[IND]←#LTYPE*(IND-#MIN)+SAVE[IND]; ! remembers the new $ENTRY to $YMTAB;
END;
! updates the frame tree structure;
$ALLOW←$ALLOW+1;
! kills the sons of WORLD,unless the predefined ones;
WHAT←FRAME:SON[F_WRLD];
WHILE WHAT AND WHAT≠F_BARM AND WHAT≠F_YARM AND WHAT≠F_BPARK AND WHAT≠F_YPARK
DO BEGIN
UNLINK(WHAT);
WHAT←FRAME:SON[F_WRLD];
END;
! kills the sons of BARM and YARM;
FRAME:SON[F_BARM]←FRAME:SON[F_YARM]←NULL_RECORD;
F_FID←F_POINTER←F_BGRASP←NULL_RECORD;
! clears BARM to define again BGRASP and POINTER, then read_barm;
ARRTRAN(FRAME:XF[F_BARM],TRANS:XF[T_NILTRANS]);
! defines again BGRASP;
FRAME:PNAME[SYMBOL:OBJECT[BGRASP←ENSYM("BGRASP",#FR,F_BGRASP←MK_REC(#FR))]]
←"BGRASP";
ARRTRAN(FRAME:XF[F_BGRASP],TRANS:XF[DOTREXP(-180,180,0,0,0,0)]);
AFX_NODE(F_BGRASP,F_BARM,#RGDLK);
! defines again POINTER;
FRAME:PNAME[SYMBOL:OBJECT[POINTER←ENSYM("POINTER",#FR,F_POINTER←MK_REC(#FR))]]
←"POINTER";
ARRTRAN(FRAME:XF[F_POINTER],
TRANS:XF[DOTREXP(-.417,13.2,-5.173,.0121,.119,3.75)]);
AFX_NODE(F_POINTER,F_BARM,#RGDLK);
F_ARM←F_BARM;
! updates the arm position;
READARM(F_BARM);
$ALLOW←$ALLOW-1;
$SCLST←$VTLST←$RTLST←$FRLST←$TRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
! assignment instruction;
! assigns to first the value of ob2. If first has not been declared
the procedure determines the type of first, according to the value
of obtype;
PROCEDURE ASGEXP(STRING FIRST; RANY OB2;INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL) OB1;
IFC #KILL THENC $LAST←ASG;ENDC ! used by kill;
$ALLOW←$ALLOW+1; ! to avoid updating display;
IF OBTYPE=#FR
THEN BEGIN
REAL ARRAY FXF[1:5,1:4];RPTR(FRAME) FR1;
FR1←FR_INSERT(FIRST);
ABSXF(OB2,FXF);
SETABS(FR1,FXF);
END
ELSE BEGIN
OB1←INSERT(FIRST,OBTYPE); ! inserts in $YMTAB,if not inserted;
SYMBOL:OBJECT[OB1]←OB2;
END;
$ALLOW←$ALLOW-1; ! for display;
IFC #DISPL THENC UPDATE;ENDC
END;
! tree operations: affixcode,unfixcode (afx_node);
! affixes the frame pointed by n to the frame pointed by d, as indicated
by how;
INTERNAL
PROCEDURE AFX_NODE(RPTR(FRAME)N,D;INTEGER HOW);
BEGIN
OWN REAL ARRAY XFTMP1,XFTMP2[1:5,1:4];
IF HOW=#INDLK
THEN ABSXF(N,FRAME:XF[N])
ELSE BEGIN ! xf[n]←inv(absxf[d])*absxf[n];
ABSXF(D,XFTMP2);
XFINV(XFTMP2,XFTMP1);
ABSXF(N,XFTMP2);
XFXF(XFTMP1,XFTMP2,FRAME:XF[N]);
END;
LINKFR(N,D); ! sets links in frame tree;
FRAME:HOWLINKED[N]←HOW;
END;
PROCEDURE UFX_NODE(RPTR(FRAME)EL1,EL2);
BEGIN
OWN REAL ARRAY FXF[1:5,1:4];
ABSXF(EL1,FXF); ! fxf=absolute value of frame1;
ARRTRAN(FRAME:XF[EL1],FXF); ! assigns absolute value to frame;
UNLINK(EL1); ! breaks links in tree;
FRAME:HOWLINKED[EL1]←#INDLK;
LINKFR(EL1,F_WRLD); ! sets new links;
END;
! affixes frame1 to frame2, as indicated by afftype;
PROCEDURE AFFIXCODE(STRING FRAME1,FRAME2; INTEGER AFFTYPE);
BEGIN
RPTR(FRAME) N,D;
IFC #KILL THENC $LAST←AFX;ENDC ! for kill instruction;
D←BELONGS (FRAME2,#FR); ! frame2 must be a frame;
N←BELONGS (FRAME1,#FR); ! frame1 must be a frame;
IFC #KILL THENC SAVTRE(CHECK(FRAME1,#FR));ENDC ! saves tree for kill instruction;
AFX_NODE(N,D,AFFTYPE); ! affixes n to d;
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
! unfixes frame1 and affixes it independently to world;
PROCEDURE UNFIXCODE(STRING FRAME1,FRAME2);
BEGIN
RPTR(FRAME)EL1,EL2;
IFC #KILL THENC $LAST←AFX;ENDC ! for kill instruction;
EL1←BELONGS (FRAME1,#FR); ! frame1 must be a frame;
EL2←BELONGS (FRAME2,#FR); ! frame2 must be a frame;
IF EL2≠F_WRLD
THEN
WHILE FRAME:DAD[EL1]≠EL2
DO BEGIN
PRINT(FRAME2," is not the dad of ",FRAME1," Try again ");
FRAME2←RECOVER(FRAME2);
EL2←BELONGS(FRAME2,#FR);
END;
IFC #KILL THENC SAVTRE(CHECK(FRAME1,#FR));ENDC ! saves tree for kill instruction;
UFX_NODE(EL1,EL2);
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
! tree operations: copycode,copy,copy_tree;
! copies the subtree rooted at startfr and affixes it to finalfr.
Prefix is used to build the names of the new frames;
PROCEDURE PCOPY(RPTR(FRAME) STARTFR,FINALFR; STRING PREFIX);
BEGIN
OWN REAL ARRAY FXF[1:5,1:4];INTEGER LINK;RPTR(FRAME)ROOT;
RPTR(FRAME) RECURSIVE PROCEDURE COPY_TREE(RPTR(FRAME) ND);
BEGIN
! copies the structure rooted at ND. Leaves copy (NND)
affixed to DAD[ND];
RPTR(FRAME) NND,KIDS;
STRING OLDNAME,LEAVE,NEWNAME;
OLDNAME←FRAME:PNAME[ND];
! constructs the new name of the frame: if the name of the copied
frame contains an underscore, the part before it is substituted
by prefix, otherwise prefix is prefixed;
LEAVE←SCAN(OLDNAME,$DSHTAB,$BRCHR);
IF $BRCHR≠0
THEN NEWNAME←PREFIX&OLDNAME
ELSE NEWNAME←PREFIX&LEAVE;
NND←FR_INSERT(NEWNAME); ! inserts a new frame;
ARRTRAN(FRAME:XF[NND],FRAME:XF[ND]);
FRAME:HOWLINKED[NND]←FRAME:HOWLINKED[ND];
KIDS←FRAME:SON[ND];
WHILE KIDS≠NULL_RECORD DO
BEGIN
LINKFR(COPY_TREE(KIDS),NND);
KIDS←FRAME:EBRO[KIDS];
END;
RETURN(NND);
END;
ROOT←COPY_TREE(STARTFR); ! copies the subtree;
LINKFR(ROOT,FINALFR); ! sets new links;
IFC #DISPL THENC UPDATE;ENDC
END;
! merges the subtrees under startfr as sons of finalfr. Prefix is
used to build the names of new frames;
PROCEDURE PMERGE(RPTR(FRAME) STARTFR,FINALFR;STRING PREFIX);
BEGIN
RPTR(FRAME)TEMP,BROTHER;
TEMP←FRAME:SON[STARTFR];
DO BEGIN
BROTHER←FRAME:EBRO[TEMP];
PCOPY(TEMP,FINALFR,PREFIX); ! copies one subtree;
TEMP←BROTHER;
END
UNTIL TEMP=NULL_RECORD;
END;
! executes copy or merge operation on frame1 and frame2. Name indicates
the required operation(copy/merge);
PROCEDURE COPYCODE(STRING NAME,FRAME1,FRAME2);
BEGIN
RPTR(FRAME) FR1,FR2;STRING PREFIX,ANSWER;
$ALLOW←$ALLOW+1;
FR1←BELONGS (FRAME1,#FR); ! frame1 must be a frame;
FR2←BELONGS (FRAME2,#FR); ! frame2 must be a frame;
! chooses the prefix for the new names: if the name of frame2 contains an
underscore takes the part before it, otherwise takes the first three
characters (long names) or all the name and asks for a confirmation;
ANSWER←FRAME:PNAME[FR2];
PREFIX←SCAN(ANSWER,$DSHTAB,$BRCHR);
IF $BRCHR=0 AND
LENGTH(PREFIX)>5 THEN
PREFIX←FRAME:PNAME[FR2] [1 FOR 3];
PRINT("it's OK to prefix to the new names ");
PREFIX←RECOVER(PREFIX)&"_";
IFC #KILL THENC $LAST←CPY;ENDC ! changed after if merge;
IF NAME="COPY"
THEN PCOPY(FR1,FR2,PREFIX)
ELSE PMERGE(FR1,FR2,PREFIX);
$ALLOW←$ALLOW-1;
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
! arm interactions: read_pos,readarm,asgloc,frasg,inputcode;
! assigns the value of pos(pointer or arm) to the frame fra. If direct
is indicated uses it to set the rotation part;
REQUIRE "ARMINT.SAI[PNT,HE]" SOURCE_FILE;
PROCEDURE ASGLOC(RPTR(FRAME) POS,FRA;INTEGER DIRECT(#INDEF));
BEGIN
REAL ARRAY FXF[1:5,1:4];
ABSXF(POS,FXF); ! absolute value of pos;
IF DIRECT="↑"
THEN BEGIN
REAL A,B,C;
DECODE(FXF,A,B,C);
SETROT(FXF,C,0.,0.);
END
ELSE IF DIRECT="$"
THEN SETROT(fxf,0.,0.,0.)
ELSE IF DIRECT="↓"
THEN SETROT(FXF,0.,180.,0.)
ELSE IF DIRECT="α"
THEN SETROT(FXF,-180,180,0);
SETABS(FRA,FXF); ! sets value of fra;
END;
! reads the position of yellow arm (TEMPORARY);
PROCEDURE READ_YELLOW(REAL ARRAY AXF);
BEGIN
INTEGER I;STRING AA; REAL ARRAY COMP[1:6];
PRINT(" Assign 6 values (angles and positions)",CRLF);
FOR I← 1 STEP 1 UNTIL 6 DO
BEGIN
AA←INCHWL;
IFC #OUTPT THENC IF $OUT THEN CPRINT($TTYCH,AA,CRLF);ENDC
COMP[I]←REALSCAN(AA,$BRCHR);
END;
SETROT(AXF,COMP[1],COMP[2],COMP[3]);
AXF[1,4]←COMP[4];
AXF[2,4]←COMP[5];
AXF[3,4]←COMP[6];
END;
! This procedure finds out where the arm actually is and then
stores this frame as the absolute frame of the arm in the
subpart hierarchy.;
PROCEDURE READARM(RPTR(FRAME) POS);
BEGIN
OWN REAL ARRAY AXF[1:5,1:4];
$FRLST←NULL; ! frame tree modification;
IF POS = F_BARM
THEN BEGIN
READ_BLUE(AXF);
SCALAR:VALUE[S_BHAND]←BHAND;
SETABS(POS,AXF);
END
ELSE IF POS=F_YARM
THEN BEGIN
PRINT ("simulation of reading on ",frame:pname[pos]);
READ_YELLOW(AXF);
SETABS(POS,AXF);
END;
END;
! returns the pointer to the input device pos (arm or pointer);
RPTR (FRAME) PROCEDURE INPT_DEV(REFERENCE STRING POS);
BEGIN
RPTR(FRAME) FROM;
IF EQU(POS,"BARM")
THEN RETURN(F_BARM)
ELSE IF EQU(POS,"YARM")
THEN RETURN(F_YARM)
ELSE BEGIN
FROM←BELONGS(POS,#FR);
WHILE FROM≠F_BARM AND FROM≠F_YARM AND FROM≠F_POINTER
DO BEGIN
PRINT ($SEMSG[12]);
POS←RECOVER(POS);
FROM←BELONGS (POS,#FR);
END;
RETURN(FROM);
END;
END;
! reads the position of the arm from, or of the arm with pointer;
PROCEDURE READ_DEV(RPTR(FRAME) FROM);
BEGIN
IF FROM=F_POINTER THEN READARM(F_ARM) ELSE READARM(FROM);
END;
! reads the position of the device pos (arm or pointer);
PROCEDURE INPT(REFERENCE STRING POS);
BEGIN
RPTR(FRAME)FROM;
FROM←INPT_DEV(POS);
READ_DEV(FROM);
END;
! assigns to fst the values read on pos. Direct predefines the orientation;
PROCEDURE INPUTCODE(STRING FST;INTEGER DIRECT;STRING POS);
BEGIN "A"
RPTR(FRAME) FROM,FRDEF;
! asserts that the fiducial is currently at the arm frame;
PROCEDURE FIDDEF(RPTR(FRAME)FROM);
BEGIN "FIDUCIAL"
F_FID←FR_INSERT(FST); ! inserts the new frame;
! f_fid=pointer to FIDUCIAL;
IF DIRECT≠#INDEF THEN PRINT("orientation assigned not used",CRLF);
AFX_NODE(F_FID,F_WRLD,#NRGLK); ! affixes fiducial to world;
ASGLOC(FROM,F_FID); ! assigns values read to fid;
END "FIDUCIAL";
! sets the absolute frame of the pointer equal to that of the fiducial;
PROCEDURE PNTASG(RPTR(FRAME) FROM);
BEGIN "POINTER"
IF NOT F_FID THEN ABORT1("FIDUCIAL",$SEMSG[3]);
F_POINTER←FR_INSERT(FST); ! inserts the new frame;
! f_pointer=pointer to POINTER;
F_ARM←FROM; ! remembers which arm holds pointer;
IF DIRECT≠#INDEF THEN PRINT("orientation assigned not used",CRLF);
ASGLOC(F_FID,F_POINTER); ! assigns fiducial pos. to pointer;
AFX_NODE(F_POINTER,F_ARM,#RGDLK); ! affixes pointer to the arm;
END "POINTER";
IFC #KILL THENC $LAST←ASG;ENDC ! for kill instruction;
$ALLOW←$ALLOW+1;
FROM←INPT_DEV(POS); ! pos must be a input device;
READ_DEV(FROM); ! reads the arm position;
IF EQU(FST,"FIDUCIAL")
THEN FIDDEF(FROM)
ELSE IF EQU(FST,"POINTER")
THEN PNTASG(FROM)
ELSE BEGIN
FRDEF←FR_INSERT(FST); ! inserts the new frame;
ASGLOC(FROM,FRDEF,DIRECT); ! assigns value to frdef;
END;
$ALLOW←$ALLOW-1;
IFC #DISPL THENC UPDATE;ENDC
END "A";
! arm interactions: arm_check,goarm,movefrfr;
IFC #MOVE THENC
! returns the pointer to the arm affixed to obj;
RPTR(FRAME) PROCEDURE ARM_CHECK(RPTR(FRAME) OBJ);
BEGIN
RPTR(FRAME) TEMP;
IF OBJ=F_BARM OR OBJ=F_YARM
THEN RETURN(OBJ);
IF OBJ=F_POINTER
THEN RETURN(F_ARM);
IF OBJ=F_WRLD
THEN ABORT1("STATION ",$SEMSG[8]); ! impossible move the world;
TEMP←FRAME:DAD[OBJ];
WHILE TEMP≠F_WRLD
DO BEGIN
IF TEMP=F_YARM OR TEMP=F_BARM
THEN RETURN(TEMP);
TEMP←FRAME:DAD[TEMP];
END;
ABORT1(FRAME:PNAME[OBJ],$SEMSG[8]);
END;
! This procedure moves the arm MVARM to BXF;
! PARKING=1 for arm parking;
PROCEDURE GOARM(RPTR(FRAME)MVARM;REAL ARRAY BXF;INTEGER PARKING(0));
BEGIN
integer i,j;real array bbb[1:5,1:4];
! this part has been introduced to transpose the rotation part of
the matrix for movements. It would be better to insert it in the
interface part;
ARRTRAN(BBB,BXF);
FOR I←1 STEP 1 UNTIL 3 DO
FOR J←1 STEP 1 UNTIL 3 DO
BBB[I,J]←BXF[J,I];
IF MVARM=F_BARM
THEN MOVE_B(BBB,PARKING)
ELSE PRINT("simulation of yarm movement ",CRLF);
SETABS(MVARM,BXF); ! sets value of arm;
END;
! Suppose the absolute frame of the arm is AXF
the absolute frame of "motion" is MXF
and we want the new motion frame to be DEST.
We therefore have to compute the new arm frame BXF.
This means MXF = AXF * X where X is the displacement trans between the
arm and the motion frames. So X = inverse(AXF) * MXF. Then DEST = BXF * X
So, BXF = DEST * inverse(X) = DEST * inverse(MXF) * AXF.;
RPTR(TRANS)PROCEDURE MOVEFRFR(RPTR(FRAME) MVARM,OBJ,DEST);
BEGIN
OWN REAL ARRAY MXF[1:5,1:4],
AXF[1:5,1:4],
TMP[1:5,1:4];
RPTR(TRANS) BXF;
BXF←MK_REC(#TR);
if mvarm=obj
then arrtran(TRANS:xf[bxf],FRAME:xf[dest])
else begin
ABSXF(MVARM,AXF); ! AXF is arm frame;
ABSXF(OBJ,MXF); ! MXF is motion frame;
INVXFX(MXF,AXF,TMP); ! TMP = inv(MXF) * AXF;
ABSXF(DEST,AXF);
XFXF(AXF,TMP,TRANS:XF[BXF]); ! BXF = DEST*inv(MXF)*AXF;
end;
RETURN(BXF);
END;
ENDC
! arm interactions: mvfrcode,mvfrexp;
! moves fr1 to fr2 + expl.vect WRT rel (fr2 can be ⊗);
IFC #MOVE THENC
PROCEDURE MVFREXP (RPTR(FRAME)FR1,FR2);
BEGIN
RPTR(TRANS)TEMP;RPTR(FRAME)MVARM;
IFC #KILL THENC $LAST←KIL;ENDC ! unkillable instruction;
$ALLOW←$ALLOW+1;
IF FR1=F_BARM AND FR2=F_BPARK
THEN GOARM(F_BARM,FRAME:XF[F_BPARK],1)
ELSE BEGIN "MOVE"
! checks frame1 is movable and finds the arm which is affixed to;
MVARM←ARM_CHECK(FR1);
IF MVARM=F_BARM THEN READARM(MVARM); ! reads exact postion of arm;
TEMP←MOVEFRFR(MVARM,FR1,FR2);
! moves the arm ;
GOARM(MVARM,TRANS:XF[TEMP]);
END "MOVE";
$ALLOW←$ALLOW-1;
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END ;
ENDC
! arm interactions: centercode,closecode,opencode,implconstr;
IFC #MOVE THENC
! executes center instruction;
PROCEDURE CENTERCODE(STRING POS);
BEGIN
IFC #KILL THENC $LAST←KIL;ENDC ! unkillable instruction;
IF POS="BARM"
THEN BEGIN
CENT_B ;
READARM(F_BARM);
$FRLST←NULL;
$SCLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END
ELSE PRINT(#NOTYET);
END;
! executes close or open instruction. How determines if the movement is
absolute (to) or differential (by), op indicates the operation(open/close);
PROCEDURE OPCLCODE(STRING OP,HAND,HOW;REAL SCAL);
BEGIN
IFC #KILL THENC $LAST←KIL;ENDC ! unkillable instruction;
IF HAND="BHAND"
THEN BEGIN
IF HOW="TO"
THEN OPEN_B_ABS(SCAL)
ELSE IF OP="CLOSE"
THEN OPEN_B_DEL(-SCAL)
ELSE OPEN_B_DEL(SCAL);
READARM(F_BARM);
$SCLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END
ELSE PRINT(#NOTYET);
END;
! drives the indicated joint of the arm (what): movement is absolute
if how=to, differential if how=by;
PROCEDURE DRIVECODE(STRING WHAT,HOW;INTEGER JOINT;REAL SCAL);
BEGIN
IFC #KILL THENC $LAST←KIL;ENDC
IF EQU(WHAT,"BJT")
THEN BEGIN
IF EQU(HOW,"BY")
THEN DRIVE_B_DEL(JOINT,SCAL)
ELSE DRIVE_B_ABS(JOINT,SCAL);
READARM(F_BARM);
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END
ELSE IF EQU(WHAT,"YJT")
THEN PRINT(#NOTYET);
END;
ENDC
! reads an axis name and returns its number:
xhat=0,yhat=1,zhat=2;
INTEGER PROCEDURE INPT_AXIS(REFERENCE STRING AXIS);
BEGIN
LABEL LL;
LL: AXIS←RECOVER(AXIS);
IF EQU(AXIS,"XHAT") THEN RETURN(0)
ELSE IF EQU(AXIS,"YHAT") THEN RETURN(1)
ELSE IF EQU(AXIS,"ZHAT") THEN RETURN(2)
ELSE BEGIN
PRINT($SYNMSG[17],$SYNMSG[25],CRLF,"Try again ");
GOTO LL;
END;
END;
! performs a construct instruction, without arguments;
PROCEDURE IMPLCONSTR(STRING FIRST);
BEGIN
RPTR(FRAME) ELF;RPTR(TRANS)XFE;INTEGER I;
RPTR(FRAME) FROM;STRING POS,ANSWER;
RPTR(VECTOR) V1,V2,V3;
PRELOAD_WITH
"move arm to the origin of the frame"&CRLF,
"move arm to the axis ",
"move arm to the plane ";
OWN STRING ARRAY INFORM[1:3];
STRING AXIS;INTEGER F_AXIS,S_AXIS;
IFC #KILL THENC $LAST←ASG;ENDC ! for kill instruction;
$ALLOW←$ALLOW+1;
AXIS←NULL;
IF F_POINTER=NULL_RECORD
THEN PRINT("pointer not defined cannot be used",CRLF)
ELSE POS←"POINTER";
PRINT("three positions are required",CRLF);
FOR I←1 STEP 1 UNTIL 3 DO
BEGIN
! determination of the input device required;
PRINT("position ",I," read on ");
POS←RECOVER(POS);
FROM←INPT_DEV(POS); ! checks the input device;
! determination of the positions for reading;
PRINT(INFORM[I]);
IF I=2
THEN F_AXIS←INPT_AXIS(AXIS)
ELSE IF I=3
THEN BEGIN
PRINT(AXIS," - ");
AXIS←NULL;
S_AXIS←INPT_AXIS(AXIS);
IF S_AXIS=F_AXIS THEN ABORT1($SEMSG[13]);
END;
! reading of the arm position;
PRINT("type <cr> when the arm is at the desired position");
ANSWER←INCHRW;
IF ANSWER=CR
THEN ANSWER←INCHRW
ELSE ABORT1($SEMSG[13]);
READ_DEV(FROM); ! raads the appropriate arm pos.;
T_CSTR[I]←ABSLOC(FROM);
END;
! extraction of translation part;
V1←TPOS(T_CSTR[1]);
V2←TPOS(T_CSTR[2]);
V3←TPOS(T_CSTR[3]);
XFE←VVVTR(V1,V2,V3,F_AXIS,S_AXIS);
ELF←FR_INSERT(FIRST); ! inserts the new frame;
ABSSET(ELF,XFE); ! sets the new value;
$ALLOW←$ALLOW-1;
IFC #DISPL THENC UPDATE;ENDC
END;
! system facilities: editcode,renmcode;
! edits values of the variable var;
PROCEDURE EDITCODE (STRING VAR);
BEGIN
RPTR(SYMBOL)EL;INTEGER OBTYPE;
RPTR(SCALAR,VECTOR,TRANS,FRAME,ROT) TEMP;
RPTR(TREE) TEMP1;
IFC #KILL THENC $LAST←KIL;ENDC ! unkillable instruction;
EL←OLDSYM(VAR,OBTYPE); ! var must exist in $YMTAB;
TEMP←SYMBOL:OBJECT[EL];
SETFORMAT(0,7);
IF OBTYPE=#FR AND FRAME:HOWLINKED[TEMP]≠#INDLK
THEN PRINT("values of ",VAR," are relative to ",
FRAME:PNAME[FRAME:DAD[TEMP]],CRLF);
PRINT("value of ",VAR," = ");
CASE OBTYPE OF
BEGIN "CASE"
[#SC] LODED( CVGX(SCALAR:VALUE[TEMP])&CR);
[#VT] LODED(STR_VT(VECTOR:XC[TEMP],
VECTOR:YC[TEMP],(VECTOR:ZC[TEMP]),8)&CR);
[#RT] LODED(STR_RT(ROT:XF[TEMP])&CR);
[#FR] LODED("FRAME "&STR_TR(FRAME:XF[TEMP],1,8)&CR);
[#TR] LODED(STR_TR(TRANS:XF[TEMP],1,8)&CR)
END "CASE";
$TAIL←INCHWL;
IFC #OUTPT THENC IF $OUT THEN CPRINT($TTYCH,$tail,CRLF);ENDC
TEMP1←GTEXPR;
IF TREE:DTYPE[TEMP1]≠OBTYPE THEN ABORT1("new value incompatible with variable type")
ELSE IF OBTYPE=#FR THEN
ARRTRAN(FRAME:XF[TEMP],FRAME:XF[tree:data[TEMP1]]);
SYMBOL:OBJECT[EL]←TREE:DATA[TEMP1];
CASE OBTYPE OF
BEGIN
[#SC] $SCLST←NULL;
[#VT] $VTLST←NULL;
[#RT] $RTLST←NULL;
[#FR] $FRLST←NULL;
[#TR] $TRLST←NULL
END;
SETFORMAT(0,3);
IFC #DISPL THENC UPDATE;ENDC
END;
! allows renaming a variable;
PROCEDURE RENMCODE(STRING VAR);
BEGIN
RPTR(SYMBOL)OLDEL;INTEGER OBTYPE;STRING NEW;
IFC #KILL THENC $LAST←KIL;ENDC
OLDEL←OLDSYM(VAR,OBTYPE); ! var must exist in $YMTAB;
PRINT("new name = ");
NEW←RECOVER(VAR); ! reads the new name;
NEW←NEWSYM(NEW); ! checks new doesn't exist;
IFC #OUTPT THENC IF $OUT THEN CPRINT($TTYCH,NEW,CRLF);ENDC
SYMBOL:PNAME[OLDEL]←NEW; ! changes the name in record symbol;
IF OBTYPE=#FR
THEN FRAME:PNAME[SYMBOL:OBJECT[OLDEL]]←NEW;
CASE OBTYPE OF
BEGIN
[#SC] $SCLST←NULL;
[#VT] $VTLST←NULL;
[#RT] $RTLST←NULL;
[#FR] $FRLST←NULL;
[#TR] $TRLST←NULL
END;
IFC #DISPL THENC UPDATE;ENDC
END;
! parse procedures: affixproc,bailcall;
! parses the instruction
AFFIX <frame_id> TO <frame_id> {AT TRANS(<rot>,<vector>)};
PROCEDURE AFFIXPROC;
BEGIN
STRING FR1,FR2;INTEGER AFFTYPE;
$HELP←16;
FR1←IDF_READ; ! first frame;
TO_READ;
FR2←IDF_READ; ! second frame;
GTOKEN(FALSE);
IF EQU(TOKEN,"AT")
THEN BEGIN "AT"
! DO IN A BETTER WAY;
! CHECK IF THE RETURNED POINTER IS A TRANS;
RPTR(TREE)TEMP;RPTR(FRAME)EL;
$ALLOW←$ALLOW+1;
TEMP←GTEXPR; ! reads TRANS part;
EL←RELFR(BELONGS(FR2,#FR),TREE:DATA[TEMP]);
! assigns to fr1 the value of comp as relative to fr2;
ASGEXP(FR1,EL,#FR);
GTOKEN(FALSE);
$ALLOW←$ALLOW-1;
END "AT";
IF FINAL
THEN AFFIXCODE(FR1,FR2,#RGDLK)
ELSE BEGIN "D"
IF TOKEN="+" OR EQU(TOKEN,"NONRIGIDLY")
THEN AFFTYPE← #NRGLK
ELSE IF TOKEN="*" OR EQU(TOKEN,"RIGIDLY")
THEN AFFTYPE← #RGDLK
ELSE ERROR($SYNMSG[30],NULL);
SEMICOL_READ;
AFFIXCODE(FR1,FR2,AFFTYPE);
END "D";
END ;
IFC #DEBUG THENC
PROCEDURE BAILCALL;
BEGIN
SEMICOL_READ;
$ALLOW←$ALLOW+1; ! no display with bail;
BAIL;
$ALLOW←$ALLOW-1;
END;
ENDC
! parse procedures: centerproc,opclproc,constread,copyproc;
! parses the instruction
CENTER <arm>;
IFC #MOVE THENC
PROCEDURE CENTERPROC;
BEGIN "A"
STRING POS;
$HELP←24;
POS←ARM_READ; ! if the arm is not indicated BARM is assumed;
CENTERCODE(POS);
END "A";
ENDC
! parses the part of the instruction "<scalar>;
PROCEDURE OPENING(STRING FIRST,WHAT,HOW);
IFC #MOVE THENC
BEGIN
RPTR(TREE)SCAL;
$HELP←23;
SCAL←GTEXPR;
IF TREE:DTYPE[SCAL]≠#SC THEN ABORT1("scalar expected");
OLDSAV(FIRST,WHAT); ! saves for default instructions;
OPCLCODE(FIRST,WHAT,HOW,SCALAR:VALUE[TREE:DATA[SCAL]]);
END;
ELSEC ;ENDC
! parses the instructions
OPEN <hand> TO|BY <scalar>;
! CLOSE <hand> TO|BY <scalar>;
IFC #MOVE THENC
PROCEDURE OPCLPROC(STRING FIRST);
BEGIN
STRING WHAT,HOW;
$HELP←23;
WHAT←HAND_READ;
HOW←IDF_READ;
IF EQU(HOW,"TO") OR EQU(HOW,"BY")
THEN OPENING(FIRST,WHAT,HOW)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END;
ENDC
! closes any open file, after a confirmation;
PROCEDURE FCLPROC;
BEGIN
STRING ANSWER;
$HELP←36;
SEMICOL_READ;
PRINT("Any open file will be closed. Are you sure?");
ANSWER←INCHRW;
PRINT(CRLF);
ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN BEGIN
IFC #KILL THENC $LAST←KIL;ENDC
IFC #OUTPT THENC FCLOSE;ENDC
END
ELSE ABORT1($SEMSG[13]);
IFC #OUTPT THENC TTYSAVE;ENDC
$OULST←NULL;
IFC #OUTPT THENC $TTYFL←NULL;ENDC ! file status modified;
IFC #DISPL THENC UPDATE;ENDC
END;
! parses the instructions
CLOSE {<filename>} (default=last used file)
CLOSE <hand> TO|BY <scalar> (BHAND as default);
PROCEDURE CLOSEPROC;
BEGIN
STRING FL,ANSWER;
$HELP←30;
GTOKEN(FALSE);
IFC #KILL THENC $LAST←KIL;ENDC
IF FINAL THEN
IFC #OUTPT THENC AL_CLOSE($ALFL) ELSEC ABORT1(#VERSION) ENDC
ELSE
BEGIN "MORE"
IF EQU(TOKEN,"BHAND") OR EQU(TOKEN,"YHAND")
OR EQU(TOKEN,"TO") OR EQU(TOKEN,"BY")
THEN BEGIN "HAND"
STRING WHAT; INTEGER IND;
WHAT←TOKEN;
GTOKEN(FALSE);
IF FINAL
THEN
IFC #OUTPT THENC
BEGIN "FILECHECK"
IND←ISFILE(WHAT);
IF IND THEN
BEGIN
PRINT("do you want to close the file?");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN AL_CLOSE(WHAT)
ELSE ABORT1($SEMSG[13]);
END
ELSE
IF EQU(WHAT,"BHAND") OR EQU(WHAT,"YHAND") THEN
BEGIN
STRING HOW;
HOW←IDF_READ;
IF EQU(HOW,"BY") OR EQU(HOW,"TO")
THEN OPENING("CLOSE",WHAT,HOW)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END
ELSE OPENING("CLOSE","BHAND",WHAT);
END "FILECHECK"
ELSEC PRINT(#VERSION) ENDC
ELSE
IF EQU(WHAT,"TO") OR EQU(WHAT,"BY") THEN
BEGIN
STOKEN←TRUE;
OPENING("CLOSE","BHAND",WHAT); ! default=BHAND;
END
ELSE
IF EQU(TOKEN,"TO") OR EQU(TOKEN,"BY") THEN
OPENING("CLOSE",WHAT,TOKEN)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END "HAND"
ELSE
BEGIN
STOKEN←TRUE;
FL←NAMEFILE;
SEMICOL_READ;
IFC #OUTPT THENC AL_CLOSE(FL);ENDC
END;
END "MORE";
IFC #DISPL THENC UPDATE;ENDC
END;
! reads a comment. This procedure is called when { is found;
PROCEDURE COMMNT;
BEGIN
$TAIL←SCAN($LINE,$CMNTAB,$BRCHR); ! scans the command;
WHILE $BRCHR=0
DO BEGIN
$LINE←INCHWL; ! if } not found reads again;
IFC #OUTPT THENC IF $OUT THEN CPRINT($TTYCH,$LINE,CRLF);ENDC
$TAIL←SCAN($LINE,$CMNTAB,$BRCHR);
END;
END;
! parses the instructions
MERGE <frame_id> INTO <frame_id>
COPY <frame_id> INTO <frame_id>
First is MERGE or COPY;
PROCEDURE COPYPROC(STRING FIRST);
BEGIN
STRING FR1,FR2;
$HELP←14;
FR1←IDF_READ; ! reads first frame;
INTO_READ; ! reads INTO;
FR2←IDF_READ; ! reads second frame;
SEMICOL_READ;
COPYCODE(FIRST,FR1,FR2);
END;
! parse procedures: declproc,deleteproc,driveproc,editproc,exitproc,explass,freeproc;
! parses the declaration instructions
SCALAR <id>,<id>,...
VECTOR <id>,<id>,...
FRAME <id>,<id>,...
ROT <id>,<id>,...;
PROCEDURE DECLPROC (INTEGER OBTYPE);
BEGIN
$HELP←0;
DO BEGIN "A"
GTOKEN;
IF #TOKEN ≠UNDECLARED_TYPE
THEN ERROR($SYNMSG[21],$SYNMSG[25])
ELSE BEGIN
IFC #KILL THENC $LAST←DECL;ENDC ! for kill instruction;
CASE OBTYPE OF
BEGIN "CASE"
[#SC] NEW_SC(TOKEN);
[#VT] NEW_VT(TOKEN);
[#RT] NEW_RT(TOKEN);
[#FR] NEW_FR(TOKEN);
[#TR] NEW_TR(TOKEN)
END "CASE";
END;
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL
THEN BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
ERROR($SYNMSG[1],$SYNMSG[25] );
END;
END "A"
UNTIL FINAL;
END;
! used after reading DISTANCE to read VECTOR in declaration statement;
PROCEDURE DIMPROC;
BEGIN
STRING VET;
VET←IDF_READ;
IF EQU(VET,"VECTOR")
THEN DECLPROC(#VT)
ELSE ERROR($SYNMSG[34],NULL);
END;
! parses the instructions
DELETE <variable>,<variable>,..
DELETE (deletes all the variables defined by the user);
PROCEDURE DELETEPROC;
BEGIN
STRING VAR;
$HELP←1;
GTOKEN(FALSE);
IF FINAL
THEN BEGIN ! deletes all the variables;
STRING ANSWER;
PRINT("are you sure? ");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN RESET
ELSE ABORT1($SEMSG[13]);
END
ELSE BEGIN
STOKEN←TRUE;
$ALLOW←$ALLOW+1;
DO BEGIN "A"
VAR←IDF_READ;
KILLVAR(TOKEN);
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL
THEN BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
ERROR($SYNMSG[1],$SYNMSG[25] );
END;
END "A"
UNTIL FINAL;
$ALLOW←$ALLOW-1;
IFC #DISPL THENC UPDATE;ENDC
END;
END;
! reads, for DRIVE instruction, TO|BY <scalar>;
IFC #MOVE THENC
PROCEDURE JT_READ(STRING WHAT,HOW;INTEGER JOINT);
BEGIN "J"
RPTR(TREE) SCAL;
$HELP←22;
SCAL←GTEXPR;
IF TREE:DTYPE[SCAL]≠#SC THEN ABORT1("SCALAR EXPECTED");
OLDSAV("DRIVE",CVS(JOINT)); ! saves for default instructions;
DRIVECODE(WHAT,HOW,JOINT,SCALAR:VALUE[TREE:DATA[SCAL]]);
END "J";
! parses the instruction
DRIVE BJT|YJT (#) TO|BY <scalar>;
PROCEDURE DRIVEPROC;
BEGIN
STRING HOW;
STRING WHAT;INTEGER JOINT;
$HELP←22;
WHAT←IDF_READ;
IF EQU(WHAT,"BJT") OR EQU(WHAT,"YJT")
THEN BEGIN
LPAR_READ; ! reads "(number)";
GTOKEN;
JOINT←INTSCAN(TOKEN,$BRCHR);
IF JOINT<1 OR JOINT>7
THEN ERROR(joint,"joint not existent");
RPAR_READ;
HOW←IDF_READ;
IF EQU(HOW,"BY") OR EQU(HOW,"TO")
THEN JT_READ(WHAT,HOW,JOINT)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END
ELSE ERROR("--→ BJT or YJT ",$SYNMSG[25]);
END;
ENDC
PROCEDURE EDITPROC(STRING WHAT);
BEGIN
STRING VAR;
IF EQU(WHAT,"EDIT")THEN $HELP←37 ELSE $HELP←38;
VAR←IDF_READ;
SEMICOL_READ;
IF EQU(WHAT,"EDIT") THEN EDITCODE(VAR)ELSE RENMCODE(VAR);
END;
PROCEDURE EXITPROC;
BEGIN
$HELP←9;
SEMICOL_READ;
!SKIP!←ALT ;
END;
! parse procedures: inputproc,killproc,vtrtpart,moveproc,axmovproc;
PROCEDURE INPUTPROC(STRING FIRST;INTEGER DIRECT);
BEGIN
STRING POS;
$HELP←10;
POS←DEV_READ;
INPUTCODE(FIRST,DIRECT,POS);
END;
IFC #KILL THENC
PROCEDURE KILLPROC;
BEGIN
$HELP←39;
SEMICOL_READ;
KILLCD($LAST);
IFC #DISPL THENC UPDATE;ENDC
$LAST←KIL; ! unkillable instruction;
END;
ENDC
! moves the frame fr1 along axis by scal;
IFC #MOVE THENC
PROCEDURE ALONGPROC(STRING AXIS,FRA1);
BEGIN
RPTR(TREE) SCAL;RPTR(VECTOR)COMP;RPTR(FRAME)FRAM1,FRAM2;
$HELP←21;
SCAL←GTEXPR;
IF TREE:DTYPE[SCAL]≠#SC THEN ABORT1("SCALAR EXPECTED");
COMP←MK_REC(#VT);
IF AXIS="X" THEN VECTOR:XC[COMP]←SCALAR:VALUE[TREE:DATA[SCAL]]
ELSE IF AXIS="Y" THEN VECTOR:YC[COMP]←SCALAR:VALUE[TREE:DATA[SCAL]]
ELSE VECTOR:ZC[COMP]←SCALAR:VALUE[TREE:DATA[SCAL]];
OLDSAV("MOVE"&AXIS[1 TO 1],FRA1); ! saves for default instructions;
FRAM1←BELONGS(FRA1,#FR);
FRAM2←MK_REC(#FR);
MVFREXP(FRAM1,OPFRVT(COMP,FRAM1,"+"));
END;
! moves the frame along one axis by a scalar;
PROCEDURE AXMOVPROC;
BEGIN
STRING FRA1,AXIS;
$HELP←21;
AXIS←TOKEN[5 TO 5];
FRA1←MVFR_READ;
BY_READ;
ALONGPROC(AXIS,FRA1);
END;
! reads/exec TO <fr>+<vt>{wrt <fr>} or BY <vector>{wrt <fr>};
PROCEDURE TOBYPROC(STRING HOW);
BEGIN
RPTR(FRAME) FRAM1,FRAM2;RPTR(TREE)TEMP;
$HELP←20;
IF EQU(TOKEN,"BY")
THEN BEGIN
! MOVE<fr>BY<vt> ≡ MOVE<fr>TO⊗+<vt>;
TOKEN←OLDOBJ;
#TOKEN←ID_TYPE;
STOKEN←TRUE;
$TAIL←"+"&$TAIL;
END;
TEMP←GTEXPR;
IF TREE:DTYPE[TEMP]≠#FR THEN ABORT1("frame expected");
FRAM2←TREE:DATA[TEMP];
FRAM1←BELONGS (OLDOBJ,#FR);
MVFREXP(FRAM1,FRAM2);
END;
! reads move <frame_id> to/by/along <axis> ;
PROCEDURE MOVEPROC;
BEGIN
STRING FR1,AXIS;
$HELP←20;
FR1←IDF_READ;
GTOKEN;
OLDSAV("MOVE",FR1);
IF EQU(TOKEN,"TO") OR EQU(TOKEN,"BY")
THEN TOBYPROC(TOKEN)
ELSE IF EQU(TOKEN,"ALONG")
THEN BEGIN
AXIS←AXIS_READ;
BY_READ;
ALONGPROC(AXIS,FR1);
END
ELSE ERROR($SYNMSG[9],$SYNMSG[25]);
END;
ENDC
! parse procedures: other;
IFC #MOVE THENC
PROCEDURE DEFLT(STRING HOW);
BEGIN
IF EQU(OLDCMD,"OPEN") OR EQU(OLDCMD,"CLOSE")
THEN OPENING(OLDCMD,OLDOBJ,HOW)
ELSE IF EQU(OLDCMD,"MOVEX")OR EQU(OLDCMD,"MOVEY")OR EQU(OLDCMD,"MOVEZ")
THEN IF HOW="BY"
THEN ALONGPROC(OLDCMD[5 FOR 1],OLDOBJ)
ELSE ERROR($SYNMSG[10],$SYNMSG[25])
ELSE IF EQU(OLDCMD,"DRIVE")
THEN JT_READ("BJT",HOW,CVD(OLDOBJ))
ELSE IF EQU(OLDCMD,"MOVE")
THEN TOBYPROC(HOW);
END;
ENDC
PROCEDURE ASGMNT(STRING FIRST);
BEGIN "A"
RPTR(TREE)EXPR;
IF EQU(FIRST,"BARM") OR EQU(FIRST,"YARM")
THEN BEGIN ! BARM← or YARM← are enoug to update the;
GTOKEN(FALSE); ! arm position;
IF FINAL
THEN BEGIN
IF EQU(FIRST,"BARM")
THEN READARM(F_BARM)
ELSE READARM(F_YARM);
$FRLST←NULL;IFC #DISPL THENC UPDATE;ENDC
RETURN;
END;
END
ELSE GTOKEN;
IF EQU(TOKEN,"CONSTRUCT")
THEN BEGIN ! if CONSTRUCT with no arguments no GTEXPR call;
GTOKEN(FALSE); ! otherwise GTEXPR is called to do the computation;
IF FINAL THEN IMPLCONSTR(FIRST)
ELSE BEGIN
$TAIL←"CONSTRUCT "&TOKEN&$TAIL;
EXPR←GTEXPR;
ASGEXP(FIRST,TREE:DATA[EXPR],TREE:DTYPE[EXPR]);
END;
END
ELSE IF EQU(TOKEN,"INPUT")
THEN INPUTPROC(FIRST,#INDEF)
ELSE IF TOKEN="↑" OR TOKEN="↓" or TOKEN="$" or TOKEN="α"
THEN BEGIN "INPUT"
INTEGER DIRECT;
DIRECT←TOKEN; ! direct=orientation required;
GTOKEN;
IF EQU(TOKEN,"INPUT")
THEN INPUTPROC(FIRST,DIRECT)
ELSE ERROR($SYNMSG[20],$SYNMSG[25]);
END "INPUT"
ELSE BEGIN
STOKEN←TRUE;
EXPR←GTEXPR;
ASGEXP(FIRST,TREE:DATA[EXPR],TREE:DTYPE[EXPR]);
END;
END "A";
PROCEDURE OTHER;
BEGIN
STRING FIRST;
$HELP←41;
FIRST←TOKEN;
GTOKEN;
IF TOKEN="←"
THEN ASGMNT(FIRST)
ELSE IF EQU(first,"BY") OR EQU(first,"TO")
THEN BEGIN
STOKEN←TRUE;
IFC #MOVE THENC DEFLT(FIRST) ELSEC PRINT(#VERSION);ENDC
END
ELSE ERROR($SYNMSG[32],NULL);
END;
! parse procedures: parking,readproc,renmproc,writeproc,unfixproc;
IFC #MOVE THENC
PROCEDURE PARKING;
BEGIN
STRING PAR;
$HELP←25 ;
PAR←TOKEN;
SEMICOL_READ;
IFC #KILL THENC $LAST←KIL;ENDC
IF PAR="BPARK" or par="PARK"
THEN GOARM(F_BARM,FRAME:XF[F_BPARK],1);
IF PAR="PARK" OR PAR="YPARK"
THEN GOARM(F_YARM,FRAME:XF[F_YPARK]);
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
ENDC
IFC #OUTPT THENC
PROCEDURE READPROC;
BEGIN
STRING FILE;
$HELP←34;
FILE←"DECLAR.AL"; ! default value;
GTOKEN(FALSE);
IF NOT FINAL
THEN BEGIN
STOKEN←TRUE;FILE←NAMEFILE;SEMICOL_READ;
END;
READCODE(FILE);
END;
PROCEDURE FSAVPROC;
BEGIN
$HELP←35;
SEMICOL_READ;
FSAVE;
END;
PROCEDURE WRITEPROC;
BEGIN "A"
STRING FILE,ROOT,WHAT;RPTR(FRAME)EL;
WHAT←TOKEN; ! SAVE or WRITE;
IF WHAT="WRITE" THEN $HELP←31 ELSE $HELP← 32;
FILE←$ALFL;ROOT←"STATION"; ! default values;
GTOKEN(FALSE);
IFC #KILL THENC $LAST←KIL;ENDC
IF NOT FINAL
THEN IF EQU(TOKEN,"FROM")
THEN BEGIN
ROOT←IDF_READ;
SEMICOL_READ;
END
ELSE BEGIN "B"
STOKEN←TRUE;
FILE←NAMEFILE;
ROOT←FROMPART;
END "B";
EL←BELONGS(ROOT,#FR);
IF WHAT="WRITE" THEN WRITECODE(FILE,EL) ELSE SAVECODE(FILE,EL);
IFC #DISPL THENC UPDATE;ENDC
END "A";
ENDC
PROCEDURE UNFIXPROC;
BEGIN
STRING FR1,FR2;
$HELP←15;
FR1←IDF_READ;
FR2←FROMPART;
UNFIXCODE(FR1,FR2);
END;
! parse;
REQUIRE "OPDECL.SAI[PNT,he]" SOURCE_FILE;
define tokencodes "[][]" =[
ZZ("→", backarrow_X, #TERM)
ZZ(["("], LPAREN_X, #FACTOR)
ZZ("*", times_X, #TERM)
ZZ("+", Plus_X, #EXP)
ZZ("-", minus_X, #EXP)
ZZ(".", dot_X, #TERM)
ZZ("/", divide_X, #TERM)
XX(TRUE, AFFIX, AFFIXPROC)
ZZ("AXIS", AXIS_X, #FACTOR)
XX(#DEBUG, BAIL, BAILCALL)
XX(#MOVE, BPARK, PARKING)
XX(#MOVE, CENTER, CENTERPROC)
XX(TRUE, CLOSE, CLOSEPROC)
XX(TRUE, CLOSE_FILES, FCLPROC)
ZZ("CONSTRUCT", CONSTRUCT_X, #FACTOR)
XX(TRUE, COPY, COPYPROC(TOKEN))
XX(TRUE, DELETE, DELETEPROC)
XX(TRUE, DISTANCE, DIMPROC)
XX(#MOVE, DRIVE, DRIVEPROC)
XX(#MOVE, EDIT, EDITPROC("EDIT"))
XX(TRUE, EXIT, EXITPROC)
XXZZ(TRUE, FRAME, DECLPROC(#FR), FRAME_X, #FACTOR)
XX(TRUE, MERGE, COPYPROC(TOKEN ))
XX(#MOVE, MOVE, MOVEPROC)
XX(#MOVE, MOVEX, AXMOVPROC)
XX(#MOVE, MOVEY, AXMOVPROC)
XX(#MOVE, MOVEZ, AXMOVPROC)
XX(#MOVE, OPEN, OPCLPROC(TOKEN ))
ZZ("ORIENT", ORIENT_X, #FACTOR)
XX(#MOVE, PARK, PARKING)
ZZ("POS", POS_X, #FACTOR)
XX(TRUE, READ, IFC #OUTPT THENC READPROC ELSEC PRINT(#VERSION) ENDC)
ZZ("REL", rel_X, #TERM)
XX(TRUE, RENAME, EDITPROC("RENAME"))
XXZZ(TRUE, ROT, DECLPROC(#RT), ROT_X, #FACTOR)
XX(TRUE, SAVE, IFC #OUTPT THENC WRITEPROC ELSEC PRINT(#VERSION) ENDC)
XX(TRUE, SAVE_FILES, IFC #OUTPT THENC FSAVPROC ELSEC PRINT(#VERSION) ENDC)
XX(TRUE, SCALAR, DECLPROC(#SC))
XXZZ(TRUE, TRANS, DECLPROC(#TR), TRANS_X, #FACTOR)
XX(TRUE, UNFIX, UNFIXPROC)
ZZ("UNIT", UNIT_X, #FACTOR)
XXZZ(TRUE, VECTOR, DECLPROC(#VT), VECTOR_X, #FACTOR)
XX(TRUE, WRITE, IFC #OUTPT THENC WRITEPROC ELSEC PRINT(#VERSION) ENDC)
ZZ("WRT", WRT_X, #TERM)
XX(#MOVE, YPARK, PARKING)
ZZ("|", MAGNITUDE_X, #FACTOR)
];
define res_count = 0;
redefine zz(arg1,arg2,arg3)"[][]"=[redefine res_count=res_count+1;];
redefine xxzz(#flag,str,oper,arg1,arg2)"[][]"=[redefine res_count=res_count+1;];
redefine xx(#flag, str, oper)"[][]"=[
ifc #flag thenc
redefine res_count=res_count+1;endc
];
tokencodes;
redefine xx(#flag,str,oper)"[][]" =
[ifc #flag thenc "str", elsec endc ];
redefine xxzz(#flag,str,oper,arg1,arg2)"[][]"=["str",];
redefine zz(arg1,arg2,arg3)"[][]"=[arg1,];
preset_array( rescode , tokencodes , string , 1 , res_count);
define xx_count=0;
redefine xx(#flag,str,oper)"[][]"=[
ifc #flag thenc redefine xx_count=xx_count+1;
xx_count*(ROT_X+1)*#DTYPE, elsec endc];
redefine zz(arg1,arg2,arg3)= [arg2*#dtype+arg3,];
redefine xxzz(#flag,str,oper,arg1,arg2)"[][]"=[
redefine xx_count=xx_count+1;
(xx_count*(rot_x+1)+arg1)*#dtype+arg2, ];
preset_array(tcodes, tokencodes, integer, 1, res_count);
external integer res_class,tokenindex,tokenclass;
internal INTEGER PROCEDURE decSTR(string VAL);
BEGIN INTEGER L,M,U,I1,I2; STRING S1,S2;
L←1; U←res_count;
DO begin M←(U+L)/2;
IF EQU(S1←rescode[M],S2←val) THEN
begin res_class←TCODES[M] DIV( (ROT_X+1)*#DTYPE);
tokenclass←tcodeS[m] mod #dtype;
tokenindex← (tcodeS[m] div #dtype) mod (rot_x+1);
RETURN(M);
end
ELSE DO begin I1←LOP(S1); I2←LOP(S2); end until i1≠i2;
if i1>i2 then U←M-1 ELSE L←M+1;
end UNTIL L>U;
res_class←tokenclass←tokenindex←0;
RETURN(0);
END;
RECURSIVE PROCEDURE PARSE;
BEGIN "PARSE"
GTOKEN; ! reads first token;
IF TOKEN="?"
THEN IFC #HELP
THENC HELPREQUEST
ELSEC PRINT(#VERSION) ENDC
ELSE IF EQU(TOKEN,"COMMENT")
THEN BEGIN END
ELSE IF TOKEN="{"
THEN COMMNT
ELSE IF EQU(TOKEN,"KILL")
THEN IFC #KILL THENC
KILLPROC ELSEC PRINT(#VERSION) ENDC
ELSE BEGIN
IFC #KILL THENC INIKIL;ENDC ! initialization of stacks for kill;
IF "A"≤ TOKEN ≤"Z" THEN
CASE res_class of
BEGIN "CASE"
redefine xx(#flag, str,oper)"[][]"=[
ifc #flag thenc ; oper elsec endc];
redefine xxzz(#flag, str,oper,arg1,arg2)"[][]"=[
; oper ];
redefine zz(arg1,arg2,arg3)"[][]"=[];
OTHER
tokencodes
END "CASE"
ELSE
IFC #ARROW THENC
IF TOKEN="↑"
THEN BEGIN
$ARROW←$ARROW+20;
UPDATE;
END
ELSE IF TOKEN="↓"
THEN BEGIN
$ARROW←$ARROW-20;
UPDATE;
END
ELSE IF #TOKEN=INT_TYPE
THEN BEGIN
INTEGER NUM;
NUM←INTSCAN(TOKEN,$BRCHR);
GTOKEN;
IF TOKEN="↓" THEN $ARROW←$ARROW-NUM*20
ELSE IF TOKEN="↑" THEN $ARROW←$ARROW+NUM*20
ELSE ERROR($SYNMSG[32],NULL);
UPDATE;
END
ELSE ENDC
BEGIN
$HELP←8;
ERROR($SYNMSG[31],NULL);
END
END;
END "PARSE";
IFC #DEBUG THENC
REAL ARRAY MATRIX[1:5,1:4];
REAL ARRAY JOINTS[1:7];
! prints the 5 x 4 array;
PROCEDURE ARRPRINT(REAL ARRAY BBB);
BEGIN INTEGER I,J;
FOR I←1 STEP 1 UNTIL 4 DO
BEGIN
FOR J←1 STEP 1 UNTIL 4 DO
PRINT(" ",BBB[I,J]);
PRINT(CRLF);
END;
END;
ENDC
! main program;
REQUIRE "INIT[PNT,HE]" LOAD_MODULE;
EXTERNAL PROCEDURE INIT;
INIT;
TTYUP(TRUE); ! conversion to upper cases;
IFC #DISPL THENC INIDPY;ENDC
PRINT("POINTY is ready. You can exit typing <meta-control-ALT>.",CRLF);
IFC #HELP THENC PRINT("If you need help you can type ? in any moment.",CRLF);ENDC
IFC #OUTPT THENC TTYSAVE; STOKEN←FALSE; ENDC ! allows opening a file to save
READARM(F_BARM);
$ALLOW←$ALLOW-1;
IFC #DISPL THENC UPDATE;ENDC
OUTSTR("* ");
WHILE TRUE DO
BEGIN
IFC #OUTPT THENC IF $READ THEN READEXEC;ENDC
$LINE←INCHWL; ! reads one line on tty;
IF !SKIP!= ALT THEN DONE; ! ALT=cntrl-meta-alt;
IFC #OUTPT THENC IF $OUT THEN CPRINT($TTYCH,$LINE,CRLF);ENDC
! to allow more than one instruction in one input line;
WHILE $LINE DO
BEGIN
$NEXT ←$LINE; ! saves the line;
$TAIL←SCAN($LINE,$SCNTAB,$BRCHR); ! scans until ? or { or ;
IF $BRCHR=0 THEN $TAIL←$TAIL&CR; ! if no break found adds a CR;
PARSE; ! parses the instruction;
STOKEN←FALSE;
END;
STOKEN←FALSE;
IF !SKIP!=ALT THEN DONE; ! EXIT instruction read;
OUTSTR("* ");ESC_P;
MAINL: END;
IFC #MOVE THENC GOARM(F_BARM,FRAME:XF[F_BPARK]);ENDC ! parks the arm;
PRINT("bye,bye",CRLF);
LODED("dea elf"&CRLF&CRLF); ! to avoid forgetting to deassign;